Visual Basic Toolbox/Visual Basic Toolbox (P.I.E.)(1996).ISO/graphics/bitvctr/bitvectr.cls

Text File | 1995-12-04 | 5.3 KB | 251 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "BitVector"
Attribute VB_Creatable = True
Attribute VB_Exposed = True
'
' BitVector Class
' Copyright ⌐ 1995-1996 by Gregg S. Irwin. All Rights Reserved.
'

Option Explicit
DefInt A-Z

Const CLASS_NAME = "BitVector"
Const CLASS_VERSION = "100"


' * PROPERTIES *
' .NumElements

' * METHODS    *
' .ClearAll
' .ClearBit (BitIndex)
' .GetBit   (BitIndex)
' .IsBitSet (BitIndex)
' .SetAll
' .SetBit   (BitIndex)
' .Toggle   (BitIndex)

' * ERRORS     *
' Subscript out of range


Const vbErrSubscriptOutOfRange = 9

Const BITS_PER_ELEMENT = 8


Private mBits()      As Byte
Private mNumElements As Long


'-- The following code:
'
'      ArrayIdx = Index \ BITS_PER_ELEMENT
'      Bit = Index Mod BITS_PER_ELEMENT
'
'   appears in a few procedures and could/should be
'   broken out into one or two procedures itself. I
'   just haven't been able to come up with a good,
'   clean syntax that I like yet.


'------------------------------------------------------
'-- CLASS EVENTS
'------------------------------------------------------

Private Sub Class_Initialize()

End Sub


Private Sub Class_Terminate()

    Erase mBits

End Sub


'------------------------------------------------------
'-- PROPERTIES
'------------------------------------------------------

Public Property Let NumElements(NewValue As Long)

    '-- TBD  Trap for bad values

    mNumElements = NewValue
    ReDim Preserve mBits(mNumElements \ BITS_PER_ELEMENT)
    'Debug.Print UBound(mBits)

End Property


Public Property Get NumElements() As Long

    NumElements = mNumElements

End Property


'------------------------------------------------------
'-- METHODS
'------------------------------------------------------

Public Sub ClearAll()
    Dim i As Long

    '-- Set bit values in BITS_PER_ELEMENT chunks for speed
    For i = LBound(mBits) To UBound(mBits)
        mBits(i) = &H0
    Next i

End Sub

Public Sub ClearBit(Index As Long)
'-- Set Bit(Index) value to 0
    Dim ArrayIdx As Long
    Dim Bit      As Long

    Call ValidateIndex(Index)

    ArrayIdx = Index \ BITS_PER_ELEMENT
    Bit = Index Mod BITS_PER_ELEMENT
    'Debug.Print "Clearing ArrayIdx:"; ArrayIdx, " Bit:"; Bit
    mBits(ArrayIdx) = mBits(ArrayIdx) And (Not (2 ^ Bit))

End Sub


Public Function GetBit(Index As Long) As Integer
'-- Returns 0 or 1

    Call ValidateIndex(Index)

    If IsBitSet(Index) Then
        GetBit = 1
    Else
        GetBit = 0
    End If

End Function


Public Function IsBitSet(Index As Long) As Boolean
    Dim ArrayIdx As Long
    Dim Bit      As Long

    Call ValidateIndex(Index)

    ArrayIdx = Index \ BITS_PER_ELEMENT
    Bit = Index Mod BITS_PER_ELEMENT
    'Debug.Print "Testing ArrayIdx:"; ArrayIdx, " Bit:"; Bit
    If mBits(ArrayIdx) And 2 ^ Bit Then
        IsBitSet = True
    Else
        IsBitSet = False
    End If

End Function


Public Sub SetAll()
    Dim i As Long

    '-- Set bit values in BITS_PER_ELEMENT chunks for speed
    For i = LBound(mBits) To UBound(mBits)
        mBits(i) = &HFF
    Next i

End Sub


Public Sub SetBit(Index As Long)
'-- Set Bit(Index) value to 1
    Dim ArrayIdx As Long
    Dim Bit      As Long

    Call ValidateIndex(Index)

    ArrayIdx = Index \ BITS_PER_ELEMENT
    Bit = Index Mod BITS_PER_ELEMENT
    'Debug.Print "Setting ArrayIdx:"; ArrayIdx, " Bit:"; Bit
    mBits(ArrayIdx) = mBits(ArrayIdx) Or 2 ^ Bit

End Sub


Public Sub ToggleBit(Index As Long)
'-- Toggle the value of Bit(Index)

    Call ValidateIndex(Index)

    If IsBitSet(Index) Then
        Call ClearBit(Index)
    Else
        Call SetBit(Index)
    End If

End Sub


'------------------------------------------------------
'-- INTERNAL SUPPORT
'------------------------------------------------------

''!! This is an unused (and untested) procedure. It's just
''   here to remind me that we can get the exponentiation
''   out of the inline code and do table lookups instead.
'Private Sub InitBitValueTable(BitValueTable() As Long)
'    Dim i As Integer
'
'    For i = 1 To BITS_PER_ELEMENT
'        BitValueTable(i) = 2 ^ i
'    Next i
'
'End Sub


Private Sub ValidateIndex(Index As Long)

    '-- Our bounds checking code is aware that this is
    '   a 0 based array of bits.
    If (Index < 0) Or (Index > (mNumElements - 1)) Then
        RaiseError vbErrSubscriptOutOfRange
    End If

End Sub


'------------------------------------------------------
'-- ERRORS
'------------------------------------------------------

' .GetErrorDesc
Private Function GetErrorDesc(ErrCode As Long) As String
    Dim Desc As String

    Select Case ErrCode
        Case vbErrSubscriptOutOfRange
            Desc = "Subscript out of Range"
        Case Else
            Desc = "Unknown error"
    End Select

    GetErrorDesc = Desc

End Function


' .RaiseError
Private Sub RaiseError(ErrCode As Long)

    Err.Raise Number:=vbObjectError + ErrCode, _
              Source:=CLASS_NAME & " " & CLASS_VERSION, _
              Description:=GetErrorDesc(ErrCode)

End Sub